googologywikiaorg-20200223-history
User blog:Rgetar/Ordinal Explorer v6.0 and Ordinal Explorer v6.1
Last month I created a program, and yesterday I created another program. Source code Delphi 7 source code. Ordinal Explorer v6.0 unit Ord; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, StrUtils, Math, ScktComp; type TForm1 = class(TForm) Button1: TButton; Label1: TLabel; Label2: TLabel; Label3: TLabel; ServerSocket1: TServerSocket; Label4: TLabel; Label5: TLabel; Label6: TLabel; Label7: TLabel; Label8: TLabel; Edit1: TEdit; Edit2: TEdit; procedure Button1Click(Sender: TObject); procedure Serversocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket); procedure Form1Create(Sender: TObject); procedure Form1Destroy(Sender: TObject); end; lis=array of record s{,i}: string; c,l,n: integer; end; rar=array0..19 of string; var Form1: TForm1; st,st1,bo,cout,qhost,fa,col,ercode: string; s: lis; f: textfile; b,bn,g,er: boolean; cn,cl,sl,br: integer; duq,uq,bro,brc: rar; implementation {$R *.dfm} // get position of last symbol p of string st (if l=true then first) function getls(st,p:string; l:boolean=false):integer; var e,np: integer; begin if length(st)=0 then result:=ifthen(l,1,0) else begin if l then e:=0 else e:=length(st)+1; np:=0; repeat if l then inc(e) else dec(e); if ste='then dec(np); if st[e=']' then inc(np); until (not l and (e=1)) or (l and (e=length(st))) or ((ste=p) and (np=0)); if not l and (e=1) and (st1<>p) then e:=0 else if l and (e=length(st)) and (ste<>p) then e:=length(st)+1; result:=e; end; end; // create boosterbase string function bb(booster,base:string):string; begin result:=''+booster+''+base; end; // get base of string st function base(st:string):string; begin result:=copy(st,getls(st,']',true)+1,length(st)); end; // get booster of string st function booster(st:string):string; begin result:=copy(st,2,getls(st,']',true)-2); end; function l(st:string;n:integer=0):string; var e:integer; begin while (st<>'') and (booster(st)<>col) do st:=base(st); for e:=1 to n do st:=bb(col,st); result:=st; end; // get successor of ordinal st function suc(st:string):string; begin result:='[]'+st; end; // get predecessor of successor ordinal st = X + 1 function pred(st:string):string; begin result:=copy(st,3,length(st)); end; // finite ordinal string st to number function fostn(st:string):integer; begin if st='' then result:=0 else result:=(length(st)+1) div 2; end; // finite ordinal e from integer to computer format function cf(e:integer):string; begin result:=''; while e>0 do begin dec(e); result:=suc(result); end; end; // compare expressions st1, st2 (if st1st2 then 1) function compare(st1,st2:string):shortint; var q1,q2,l1,l2:integer; begin if st1=st2 then result:=0 else if st1='' then result:=-1 else if st2='' then result:=1 else if (rightstr(st1,1)=col) and (rightstr(st2,1)<>col) then result:=1 else if (rightstr(st2,1)=col) and (rightstr(st1,1)<>col) then result:=-1 else if rightstr(st1,1)=col then result:=compare(leftstr(st1,length(st1)-1),leftstr(st2,length(st2)-1)) else repeat l1:=length(st1); l2:=length(st2); q1:=getls(st1,'q2:=getls(st2,'['); delete(st1,l1,1); delete(st2,l2,1); result:=compare(copy(st1,q1+1,l1),copy(st2,q2+1,l2)); if result=0 then begin delete(st1,q1,l1); delete(st2,q2,l2); if st1='' then result:=-1 else if st2='' then result:=1; end; until result<>0; end; function card(st,s:string;n:integer=0):string; var e:integer; begin while (st<>'') and (compare(s,booster(st))=1) do st:=base(st); for e:=1 to n do st:=bb(s,st); result:=st; end; function absl(st:string):string; begin if compare(col,st)=1 then result:='' else if st=col then result:=st else if compare(col,booster(st))=1 then result:=absl(base(st)) else result:=st; end; function attic(st:string):string; var x:string; begin if compare(st,col)<1 then result:=col else begin x:=booster(st); if compare(col,x)=1 then result:=bb(col,absl(st)) else result:=bb(attic(x),base(st)); end; end; function rest(st:string):string; begin if compare(col,st)=1 then result:=st else result:=rest(booster(st)); //result:=st; end; function a(st:string):string; begin result:=st; if (st<>'') and (st<>col) and (compare(col,booster(st))=1) then result:=a(base(st)); end; function fs(st,n:string):string;forward; // get cofinality of ordinal st function cof(st:string):string; var beta,x,c:string; ca:integer; begin result:='[[]'; if st<>bo then // L if (st='') or (st=col) then // 1, 6 result:=st else begin x:=booster(st); if x='' then // 2 result:='[]' else begin c:=cof(x); if c<>'[]' then // 3 begin beta:=base(st); ca:=compare(bb(attic(x),beta),c); if ca=1 then // 4, 5, 8 result:=c else if c=col then // 7 result:=st else if ca<0 then // 9 result:=cof(bb(fs(x,bb(fs(booster©,rest(x)),base©)),beta)); // 10 end; end; end; end; // get n-th element of fs of ordinal st function fs; var beta,x,c:string; i,ca:integer; begin result:=n; if st=bo then // L begin result:=col; for i:=1 to fostn(n) do result:=bb(result,col); result:=bb(bb(result,),); end else if (st<>'') and (st<>col) then // 1, 6 begin x:=booster(st); beta:=base(st); if x='' then // 2 result:=beta else begin c:=cof(x); if c='[]' then // 3 begin result:=beta; x:=base(x); for i:=1 to fostn(n) do result:=bb(x,result); end else begin ca:=compare(bb(attic(x),beta),c); if ca=1 then // 4, 5, 8 result:=bb(fs(x,n),beta) else if c=col then // 7 else if ca=0 then // 9 begin result:=beta; for i:=1 to fostn(n) do result:=bb(fs(x,result),beta); end else result:=fs(bb(fs(x,bb(fs(booster©,rest(x)),base©)),beta),n); // 10 end; end; end; end; function convert(st:string;z:boolean=false):string; begin result:=st; end; // small expansion of pair c > l function se(c,l:string; yn:integer; var n:string):string; var u:integer; begin //n:='0'; repeat result:=fs(c,n); n:=suc(n); if length(n)>35 then er:=true; until er or (l='-') or (compare(result,l)=1); if er then begin ercode:='fs is less than or equal to low element of pair'; form1.Edit1.Text:=c; form1.Edit2.Text:=l; end else if cof©<>'1' then begin for u:=3 to yn do n:=suc(n); if yn>1 then result:=fs(c,n); end; end; // levelup (q - number of levelups, yn - number of fs elements, inserted in last levelup) procedure levelup(q:integer; yn:integer=0); var e,i,y,u,j: integer; n,l,p,a,c: string; begin inc(yn); while not er and (q>0) do begin dec(q); if q>0 then j:=1 else j:=yn; e:=0; c:=se.s; i:=se.c; y:=0; form1.Label2.Caption:=inttostr(cn)+' '; form1.Label2.Refresh; repeat begin n:=cf(se.n); if i=-1 then begin l:='-'; p:=''; end else begin l:=si.s; p:=suc(l); end; if (c<>bo) and (compare(c,p)=0) then begin e:=i; if e>-1 then begin c:=se.s; i:=se.c; if i=-1 then e:=i; end; dec(cn); form1.Label2.Caption:=inttostr(cn)+' '; form1.Label2.Refresh; end else begin a:=se(c,l,j,n); {if strtoint(n)<>se.n+j then // check for cut begin er:=true; ercode:='not cut'; end;} se.n:=fostn(n); if cof©='[]' then u:=j-1 else u:=0; if (c<>bo) and (compare(c,a)<1) then begin er:=true; if compare(c,a)=0 then ercode:='fs element is equal to its argument' else ercode:='fs element is larger than its argument'; form1.Edit1.Text:=c; form1.Edit2.Text:=a; end; if er then form1.Label8.Caption:='Error: '+ercode else while ulength(s) then setlength(s,length(s)*2); form1.Label1.Caption:=inttostr(sl); form1.Label1.Refresh; e:=y; se.c:=i; se.s:=a; se.l:=ifthen(u=j,cl,cl+1); se.n:=0; if u<>j then begin n:=pred(n); a:=fs(c,n); end; end; c:=a; end; end; until er or (e=-1); //until er or (e=-1) or (sl>1000); cn:=y; inc(cl); end; end; function ruq(st:string;uq:rar):rar; var e,i:integer; begin st:=st+'='; result:=uq; while (st<>'=') and (st<>'') do begin e:=system.ord(st1)-48; delete(st,1,1); i:=pos('=',st); resulte:=leftstr(st,i-1); delete(st,1,i); end; end; function wuq(st:string):string; var e:integer; huq:rar; begin huq:=ruq(st,uq); result:=''; for e:=0 to length(uq)-1 do if huqe<>duqe then begin if result<>'' then result:=result+'='; result:=result+chr(e+48)+huqe; end; end; // get html link s, displaying string st function getrefs(s, st: string):string; begin result:=''+st+''; end; procedure ads(st:string); begin if g then cout:=cout+st else writeln(f,st); end; procedure starthtml; begin cout:=''; st:=''; //st:=' '+st; st:=' '+st; st:='sup {font-size: 0.83rem;}'+st; st:='sub {font-size: 0.83rem;}'+st; st:=' '+st; st:='sup {font-size: 0.83rem;}'+st; st:='sub {font-size: 0.83rem;}'+st; st:='